home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
EXPAND2.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
45KB
|
1,466 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#define GEN
#include "hdr.h"
#include "libhdr.h"
#include "vars.h"
#include "gvars.h"
#include "attr.h"
#include "gmainp.h"
#include "setp.h"
#include "miscp.h"
#include "gnodesp.h"
#include "gutilp.h"
#include "gmiscp.h"
#include "initobjp.h"
#include "arithp.h"
#include "chapp.h"
#include "smiscp.h"
#include "expandp.h"
static Tuple constrained_type(Symbol, Node, Node);
static int array_nelem(Node);
static void replace_name(Node, Symbol, Symbol);
static int array_nelem_defined; /* set if array_nelem undefined */
void expand_line() /*;expand_line*/
{
/* called when expander reaches line debug_line if debug_line is not
* zero. This is meant to provide useful trapping point for
* interactive debugging. ds 7-19-85
*/
}
int in_bin_ops(Symbol op) /*;in_bin_ops*/
{
/* bin_ops = {'and', 'or', 'xor', '&', '&ac', '&ca', &cc'
* '=', '/=', '<=', '>', '>=', '<',
* '+i', '-i', '*i', '/i', '**i', 'remi', 'modi',
* '+fl', '-fl', '*fl', '/fl', '**fl',
* '+fx', '-fx', '*fx', '/fx', '*fix', '*fxi', '/fxi'},
*/
return op == symbol_and || op == symbol_or || op == symbol_xor
|| op == symbol_cat || op == symbol_cat_cc || op == symbol_cat_ca
|| op == symbol_cat_ac || op == symbol_eq || op == symbol_ne
|| op == symbol_le || op == symbol_gt || op == symbol_ge
|| op == symbol_lt || op == symbol_addi || op == symbol_subi
|| op == symbol_muli || op == symbol_divi || op == symbol_expi
|| op == symbol_remi || op == symbol_modi || op == symbol_addfl
||op == symbol_subfl || op == symbol_mulfl || op == symbol_divfl
|| op == symbol_expfl || op == symbol_addfx || op == symbol_subfx
|| op == symbol_mulfx || op == symbol_divfx || op == symbol_mulfix
|| op == symbol_mulfxi || op == symbol_divfxi;
}
int in_un_ops(Symbol op) /*;in_un_ops*/
{
/* un_ops = {'not', '-ui', '+ui', 'absi', '-ufl', '+ufl', 'absfl',
* '-ufx', '+ufx', 'absfx' };
*/
return op == symbol_not || op == symbol_subui || op == symbol_addui
|| op == symbol_absi || op == symbol_subufl || op == symbol_addufl
|| op == symbol_absfl || op == symbol_subufx || op == symbol_addufx
|| op == symbol_absfx;
}
void expand_block(Node decl_node, Node stmt_node, Node exc_node, Node term_node)
/*;expand_block*/
{
Node stmt_list_node;
if (decl_node != OPT_NODE)
expand(decl_node);
stmt_list_node = N_AST1(stmt_node);
N_LIST(stmt_list_node) = tup_with(N_LIST(stmt_list_node),
(char *) copy_tree(term_node));
expand(stmt_node);
if (exc_node != OPT_NODE) {
/* Note: exc node may be a sequence of statements */
if (N_KIND(exc_node) == as_exception) {
N_AST1(exc_node) = term_node;
if (N_AST2_DEFINED(as_exception)) N_AST2(exc_node) = (Node) 0;
if (N_AST3_DEFINED(as_exception)) N_AST3(exc_node) = (Node) 0;
if (N_AST4_DEFINED(as_exception)) N_AST4(exc_node) = (Node) 0;
}
expand(exc_node);
}
}
static Tuple constrained_type(Symbol array_type, Node lbd_node, Node ubd_node)
/*;constrained_type*/
{
/*
* Given an unconstrained array type, constructs a constrained subtype
* with the given bounds.
* returns [type_name, decls] where type_name is the name of the
* constrained array subtype, and decls a list (tuple) of nodes necessary
* to elaborate the type.
*/
Symbol bt, index_name, array_name, comp_type;
Node range_node, indic_node, ix_name_node, index_node, ar_name_node,
array_node;
Tuple tup, dtup;
bt = base_type(N_TYPE(lbd_node));
/* 1- Create range node */
range_node = node_new(as_range);
N_AST1(range_node) = lbd_node;
N_AST2(range_node) = ubd_node;
indic_node = node_new(as_subtype_indic);
N_AST1(indic_node) = new_name_node(bt);
N_AST2(indic_node) = range_node;
/* 2- Create index subtype */
index_name = new_unique_name("index");
ix_name_node = new_name_node(index_name);
index_node = node_new(as_subtype_decl);
N_AST1(index_node) = ix_name_node;
N_AST2(index_node) = indic_node;
tup = constraint_new(co_range);
tup[2] = (char *) lbd_node;
tup[3] = (char *) ubd_node;
new_symbol(index_name, na_subtype, bt, tup, ALIAS(bt));
CONTAINS_TASK(index_name) = FALSE;
/* 3- Create constrained array subtype */
indic_node = node_new(as_constraint);
N_LIST(indic_node) = tup_new1( (char *) new_name_node(index_name));
array_name = new_unique_name("array");
ar_name_node = new_name_node(array_name);
array_node = node_new(as_subtype_decl);
N_AST1(array_node) = ar_name_node;
N_AST2(array_node) = indic_node;
comp_type = (Symbol) (SIGNATURE(array_type))[2];
tup = tup_new(2);
tup[1] = (char *) tup_new1( (char *) index_name);
tup[2] = (char *) comp_type;
new_symbol(array_name, na_subtype, array_type,
tup, ALIAS(array_type));
CONTAINS_TASK(array_name) = CONTAINS_TASK(array_type);
dtup = tup_new(2);
dtup[1] = (char *) index_node;
dtup[2] = (char *) array_node;
tup = tup_new(2);
tup[1] = (char *) array_name;
tup[2] = (char *) dtup;
return tup;
}
static int array_nelem(Node node) /*;array_nelem*/
{
/*
* Given a node that is appropriate for an array type, determines the
* number of elements if known statically, returns OM otherwise.
*/
Symbol node_name, type_name, index_sym;
Tuple index_list, tup;
int size, nk;
Node nod2, lbd_node, ubd_node;
Fortup ft1;
Const lbd, ubd;
/* the global (to this module) variable array_nelem_defined is set to
* FALSE if the SETL version of this procedure returns OM, TRUE otherwise
*/
array_nelem_defined = TRUE; /* assume defined */
nk = N_KIND(node);
if (nk == as_subtype_indic) {
nk = (int) N_KIND((N_AST2(node) == OPT_NODE) ?
N_AST1(node) : N_AST2(node));
nod2 = N_AST2(node);
}
if (nk == as_string_ivalue) {
return tup_size((Tuple) N_VAL(node));
}
else if (nk == as_simple_name) {
node_name = N_UNQ(node);
if (NATURE(node_name) == na_type) {
array_nelem_defined = FALSE;
return 0; /* always unconstrained */
}
else if ( NATURE(node_name) == na_subtype) {
type_name = node_name;
}
else { /* object */
type_name = N_TYPE(node);
}
tup = SIGNATURE(type_name);
index_list = (Tuple) tup[1];
size = 1;
FORTUP(index_sym = (Symbol), index_list, ft1);
tup = SIGNATURE(index_sym);
lbd_node = (Node) tup[2];
ubd_node = (Node) tup[3];
lbd = get_ivalue(lbd_node);
ubd = get_ivalue(ubd_node);
if (lbd->const_kind != CONST_OM && ubd->const_kind != CONST_OM) {
if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node))
return 0;
else
size *= get_ivalue_int(ubd_node)-get_ivalue_int(lbd_node)+1;
}
else{
array_nelem_defined = FALSE;
return 0;
}
ENDFORTUP(ft1);
return size;
}
#ifdef TBSL
/* Wrong because the type_name is the base_type*/
else if (nk == as_array_aggregate || nk == as_array_ivalue) {
type_name = N_TYPE(node);
tup = SIGNATURE(type_name);
index_list = (Tuple) tup[1];
size = 1;
FORTUP(index_sym = (Symbol), index_list, ft1);
tup = SIGNATURE(index_sym);
lbd_node = (Node) tup[2];
ubd_node = (Node) tup[3];
lbd = get_ivalue(lbd_node);
ubd = get_ivalue(ubd_node);
if (lbd->const_kind != CONST_OM &&
ubd->const_kind != CONST_OM) {
if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node)) {
return 0;
}
else {
size *= get_ivalue_int(ubd_node) - get_ivalue_int(lbd_node) +1;
}
}
else{
array_nelem_defined = FALSE;
return 0;
}
ENDFORTUP(ft1);
return size;
}
#endif
else if (nk == as_range) {
lbd_node = N_AST1(nod2);
ubd_node = N_AST2(nod2);
size = 1;
lbd = get_ivalue(lbd_node);
ubd = get_ivalue(ubd_node);
if (lbd->const_kind != CONST_OM && ubd->const_kind != CONST_OM) {
if (get_ivalue_int(ubd_node) < get_ivalue_int(lbd_node))
return 0;
else
size *= get_ivalue_int(ubd_node) - get_ivalue_int(lbd_node) +1;
}
else{
array_nelem_defined = FALSE;
retu